home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / smaltalk / st80_r41.lha / st80_r41 / ObjectDebugging.st < prev    next >
Text File  |  1993-07-23  |  33KB  |  1,028 lines
  1. "Welcome to objectDebugging.st.  This file contains the complete source to
  2. add lightweight classes and breakpoint methods to your system.  Together
  3. these two changes provide new techniques to use while debugging.  Since
  4. the code is largely uncommented, these prefatory paragraphs serve as
  5. documentation for now.  The following paragraph is a brief introduction to the
  6. purpose of this file, while the one after that explains the interface in more
  7. detail."! 
  8.  
  9. "The notion of a lightweight class comes from the desire to be able to change
  10. the behavior of a particular object without also changing all the other objects
  11. of its class.  This can be done by creating a special class for the object, but
  12. that's expensive in both time and space, so there's a need for a kind of class
  13. that's cheap to create and store--and that's what a lightweight class is.  The
  14. lightweight class is created between an object and its real class, and so any
  15. methods defined in the lightweight class apply only to a singular object. 
  16. Thus, you can modify the add: method of a particular OrderedCollection, say,
  17. without changing all the many other OrderedCollections in the image.  One of
  18. the changes you can make in a lightweight class (and in regular classes, too)
  19. is to put a breakpoint on a method.  Breakpointing a method is like adding
  20. 'self halt' as its first line, but there are some important differences.  First, it's
  21. easier to add (and remove) a breakpoint, since it's done by menu rather than
  22. by typing.  Second, adding/removing breakpoints doesn't affect the various
  23. change mechanisms, so the change set and change log don't include trivial
  24. changes for putting (and presumably later removing) a halt in a method.
  25. Finally, breakpoints are invisible in source code, so when you edit a
  26. breakpointed method in a browser (or look at it in the debugger), you see
  27. only the normally defined code--the breakpoint itself is transparent.
  28. Combining lightweight classes and breakpoints allows you to set breakpoints 
  29. on methods belonging to an individual object.  So it's possible to set a
  30. breakpoint on the add: method of one OrderedCollection without bringing the
  31. rest of the system to a grinding halt.  That kind of debugging is what our
  32. object debugging package is for."!
  33.  
  34. "The interface for all this is (I hope) relatively simple.  You can send any
  35. object the message 'browseLightweight' to create and edit its lightweight
  36. class.  (Alternatively, there's also a browseLightweight menu option from any
  37. Inspector.)  This kind of browsing creates a special Lightweight Class
  38. Browser, which looks something like a ClassBrowser, but there are several
  39. differences.  First, lightweight classes don't have protocols, so rather than
  40. seeing methods organized into protocols, you just see a list of all methods for
  41. the lightweight class.  The method display uses two formatting conventions to
  42. convey information:  methods that are defined in the lightweight class have
  43. their selectors printed in boldface, while those with breakpoints have their
  44. selectors preceded by asterisks.  Second, in the upper right hand of the
  45. browser is a text pane that lets you choose which methods to list--you can
  46. either show only methods defined in the lightweight class, or all methods up
  47. to some menu-chosen superclass.  This option is convenient since it lets you
  48. look at methods as defined in a superclass and then alter and accept them in
  49. the lightweight class.  Finally, the lightweight class browser has an inspector
  50. for the object at the bottom, because we believe users will often want to get at
  51. objects and their instance variables in the context of object debugging.
  52. Adding breakpoints is even easier:  every method list now has a menu option
  53. called 'breakpoint,' which occurs right above 'move to ...'  This option is a toggle 
  54. switch--if the method is not breakpointed, a breakpoint will be added
  55. (and the method's selector will be preceded by an asterisk to indicated this.)
  56. If the method is already breakpointed, choosing 'breakpoint' will cause the
  57. existing breakpoint to be removed.  We envision the browser will be used as
  58. follows:  a programmer finds there's a problem in a particular method, with
  59. some object behaving strangely.  So, he or she puts a breakpoint in that
  60. method or some previous one where the object is created.  When that
  61. breakpoint is triggered, the programmer opens a debugger and looks at the
  62. problem object in the inspector.  Using the browseLightweight menu option,
  63. the programmer changes or puts breakpoints on important methods of the
  64. object, and then proceeds from the debugger.  Now he/she can monitor that
  65. one object's behavior and (we hope) discover what the problem is."!
  66.  
  67. "This code was developed for Smalltalk-80 Release 4.1 for the Macintosh.  It
  68. should work on earlier releases with work on the interface, and also on
  69. compatible versions for other platforms.  We're interested in feedback on this
  70. package, so please let us know if you have comments, questions, problems,
  71. or ideas.  In particular, we're interested in whether you find these changes
  72. useful for debugging, other features you'd like to see added to this package,
  73. other debugging improvements you'd like to see in the Smalltalk
  74. environment, and finally any other uses you have for lightweight classes.
  75. Please direct any such comments or questions to Bob Hinkle at
  76. hinkle@cs.uiuc.edu."!
  77.  
  78. ByteCodeStream subclass: #CodeStream
  79.     instanceVariableNames: 'outerStream needsFrame hybrid usesOuter canCopy tempStores usedArgs usedTemps copiedVars finalNumTemps innerBlocks forContext forNonImmediate forNonSubclassable deferredBlocks method allSourceMaps optimizedBlockNodes methodClass '
  80.     classVariableNames: 'RestartSignal '
  81.     poolDictionaries: 'OpcodePool '
  82.     category: 'System-Compiler-Support'!
  83.  
  84. !CodeStream methodsFor: 'initialize-release'!
  85.  
  86. initialize
  87.     super initialize.
  88.     needsFrame := hybrid := false.
  89.     usesOuter := 256.  "infinity"
  90.     canCopy := true.
  91.     methodClass := CompiledMethod!
  92.  
  93. methodClass
  94.     ^methodClass!
  95.  
  96. methodClass: aClass
  97.     methodClass := aClass! !
  98.  
  99. CodeStream allSubInstancesDo:
  100.     [ :m |  m methodClass isNil ifTrue: [m methodClass: CompiledMethod]].
  101. CodeStream allInstancesDo:
  102.     [ :m |  m methodClass isNil ifTrue: [m methodClass: CompiledMethod]].!
  103.  
  104. !CodeStream methodsFor: 'initialize-release'!
  105.  
  106. makeMethod: methodNode
  107.     "Return an appropriate compiled code object"
  108.     | deferred |
  109.     deferred := deferredBlocks.  "makeMethodOfClass: sets it to nil"
  110.     self makeMethodOfClass: self methodClass local: false.
  111.     method mclass: class.
  112.     "Revisit all ambiguous blocks"
  113.     deferred == nil
  114.         ifFalse:
  115.             [deferred do: [:dfb | dfb complete]].
  116.     ^method! !
  117.  
  118. !Object methodsFor: 'user interface'!
  119.  
  120. browseLightweight
  121.     LightweightClassBrowser newOnObject: self.
  122.     ^self!
  123.  
  124. becomeLightweight
  125.     | lwc |
  126.     
  127.     (self dispatchingClass isKindOf: LightweightClass)
  128.         ifFalse: [lwc := LightweightClass newWithSuper: self class.
  129.             self changeClassToThatOf: lwc basicNew]! !
  130.  
  131. !Object methodsFor: 'class membership'!
  132.  
  133. dispatchingClass
  134.     <primitive: 111>
  135.     self primitiveFailed! !
  136.  
  137. !CompiledCode methodsFor: 'testing'!
  138.  
  139. isBreakpoint
  140.     ^false! !
  141.  
  142. CompiledCode variableSubclass: #CompiledMethod
  143.     instanceVariableNames: 'mclass sourceCode agent '
  144.     classVariableNames: ''
  145.     poolDictionaries: ''
  146.     category: 'Kernel-Methods'!
  147.  
  148. !CompiledMethod methodsFor: 'printing'!
  149.  
  150. agent
  151.     agent = nil ifTrue: [agent := self].
  152.     ^agent!
  153.  
  154. who 
  155.     "Answer an Array of the class in which the receiver is defined and
  156.     the selector to which it corresponds.  If the receiver is not defined
  157.     in any class, answer nil."
  158.  
  159.     | sel |
  160.     sel := mclass selectorAtMethod: self agent ifAbsent: [nil].
  161.     ^sel == nil
  162.         ifTrue: [nil]
  163.         ifFalse:    [Array with: mclass with: sel]!
  164.  
  165. printNameOn: aStream inClass: aClass
  166.     | selector class |
  167.     aClass isNil
  168.         ifTrue:
  169.             [| who |
  170.             who := self who.
  171.             who isNil
  172.                 ifTrue:
  173.                     [class := mclass.
  174.                     selector := class defaultSelectorForMethod: self agent]
  175.                 ifFalse:
  176.                     [class := who first.
  177.                     selector := who at: 2]]
  178.         ifFalse:
  179.             [class := aClass.
  180.             selector := class
  181.                     selectorAtMethod: self agent
  182.                     setClass: [:mc | ]].
  183.     aStream nextPutAll: class name.
  184.     mclass == class 
  185.         ifFalse: 
  186.             [aStream nextPut: $(.
  187.             aStream nextPutAll: mclass name.
  188.             aStream nextPut: $)].
  189.     aStream nextPutAll: '>>'.
  190.     aStream nextPutAll: selector!
  191.  
  192. agent: aCompiledMethod
  193.     agent := aCompiledMethod! !
  194.  
  195. !Behavior methodsFor: 'accessing method dictionary'!
  196.  
  197. setBreakpointAt: aSelector
  198.     | c m isBreakpoint |
  199.     c := self whichClassIncludesSelector: aSelector.
  200.     c isNil ifTrue: [^self].
  201.     m := c compiledMethodAt: aSelector.
  202.     isBreakpoint := m isBreakpoint.
  203.     self == c
  204.         ifTrue: [
  205.             isBreakpoint
  206.                 ifTrue: [m client mclass == self
  207.                     ifTrue: [m client agent: m client.
  208.                         self addSelector: aSelector withMethod: m client]
  209.                     ifFalse: [self removeSelector: aSelector]]
  210.                 ifFalse: [self addSelector: aSelector withMethod: (BreakpointMethod on: m selector: aSelector inClass: self)]]
  211.         ifFalse: [
  212.             isBreakpoint ifTrue: [m := m client].
  213.             self addSelector: aSelector withMethod:
  214.                 (BreakpointMethod on: m selector: aSelector inClass: self)]! !
  215.  
  216. !Behavior methodsFor: 'compiling'!
  217.  
  218. breakpointCompilerClass
  219.     "Answer a compiler class appropriate for source methods of this class."
  220.  
  221.     ^BreakpointCompiler! !
  222.  
  223. !Behavior methodsFor: 'testing method dictionary'!
  224.  
  225. isBreakpointAt: aSymbol 
  226.     ^(self includesSelector: aSymbol)
  227.         and: [(self compiledMethodAt: aSymbol) isBreakpoint]! !
  228.  
  229. !Inspector methodsFor: 'field list'!
  230.  
  231. fieldMenu
  232.     "Answer a Menu of operations on the variables that is to be displayed 
  233.     when the operate menu button is pressed."
  234.  
  235.     "Inspector flushMenus"
  236.     field == nil ifTrue: [^ nil].
  237.     ListMenu == nil ifTrue:
  238.         [ListMenu := PopUpMenu
  239.             labelList: #((inspect draw browseLightweight))
  240.             values: #(inspectField drawField browseLightweightField)].
  241.     ^ ListMenu! !
  242.  
  243. !Inspector methodsFor: 'private-menu messages'!
  244.  
  245. browseLightweightField
  246.     self fieldValue browseLightweight! !
  247.  
  248. !DictionaryInspector methodsFor: 'field list'!
  249.  
  250. fieldMenu
  251.     "DictionaryInspector flushMenus" 
  252.  
  253.     field == nil ifTrue:
  254.         [^PopUpMenu labels: 'add field' withCRs
  255.             values: #(addField)].
  256.     DictListMenu == nil ifTrue:
  257.         [DictListMenu := PopUpMenu
  258.             labels: 'inspect\draw\browseLightweight\references\add field\remove' withCRs
  259.             lines: #(4)
  260.             values: #(inspectField drawField browseLightweightField browseReferences
  261.                         addField removeField)].
  262.     ^DictListMenu! !
  263.  
  264. !ContextInspector methodsFor: 'field list'!
  265.  
  266. fieldMenu
  267.     "Answer a Menu of operations on variables that is to be displayed 
  268.     when the operate menu button is pressed."
  269.  
  270.     field == nil ifTrue: [^ nil].
  271.     ^PopUpMenu
  272.         labelList: #((inspect draw browseLightweight))
  273.         values: #(inspectField drawField browseLightweightField)! !
  274.  
  275. !Browser methodsFor: 'selector list'!
  276.  
  277. selectorMenu
  278.     "Answer a Menu of operations on message selectors to be 
  279.     displayed when the operate menu button is pressed."
  280.  
  281.     "Browser flushMenus"
  282.     selector == nil ifTrue: [^ nil].
  283.     MessageMenu == nil ifTrue:
  284.         [MessageMenu := PopUpMenu
  285.             labels: 'file out as...\hardcopy\spawn\senders\implementors\messages...\breakpoint\move to...\remove...' withCRs
  286.             lines: #(3 6)
  287.             values: #(fileOutMessage printOutMessage spawnMethod browseSenders browseImplementors browseMessages breakpointMethod moveMethod removeMethod)].
  288.     ^ MessageMenu! !
  289.  
  290. !Browser methodsFor: 'private-selector functions'!
  291.  
  292. breakpointMethod
  293.     selector isNil ifTrue: [^self].
  294.     self selectedClass setBreakpointAt: selector.
  295.     self changed: #selector!
  296.  
  297. formatSelector: aSymbol
  298.     | symbol mclass c |
  299.  
  300.     c := self selectedClass.
  301.     mclass := c whichClassIncludesSelector: aSymbol.
  302.     symbol := (((mclass isBreakpointAt: aSymbol) 
  303.         ifTrue: ['*']
  304.         ifFalse: [' ']), aSymbol) asText.
  305.     ^mclass = c
  306.         ifTrue: [symbol allBold]
  307.         ifFalse: [symbol]! !
  308.  
  309. !Browser class methodsFor: 'private-view creation'!
  310.  
  311. addFormattedSelectorViewTo: aContainer in: area on: aBrowser readOnly: readOnly
  312.  
  313.     | edgeDecorator view |
  314.     view := FormattedListView on: aBrowser printItems: false oneItem: readOnly
  315.             aspect: #selector change: #selector: list: #selectorList
  316.             menu: #selectorMenu initialSelection: #selector.
  317.     view printReceiver: aBrowser printMessage: #formatSelector:.
  318.     edgeDecorator := LookPreferences edgeDecorator on: view.
  319.     readOnly ifTrue: [edgeDecorator noVerticalScrollBar].
  320.     ^aContainer add: edgeDecorator in: area! 
  321.  
  322. addSelectorViewTo: aContainer in: area on: aBrowser readOnly: readOnly
  323.     ^self addFormattedSelectorViewTo: aContainer in: area on: aBrowser readOnly: readOnly!
  324.  
  325. addUnformattedSelectorViewTo: aContainer in: area on: aBrowser readOnly: readOnly
  326.  
  327.     | edgeDecorator |
  328.     edgeDecorator := LookPreferences edgeDecorator on:
  329.         (SelectionInListView on: aBrowser printItems: false oneItem: readOnly
  330.             aspect: #selector change: #selector: list: #selectorList
  331.             menu: #selectorMenu initialSelection: #selector).
  332.     readOnly ifTrue: [edgeDecorator noVerticalScrollBar].
  333.     ^aContainer add: edgeDecorator in: area! !
  334.  
  335. !NotifierView class methodsFor: 'instance creation'!
  336.  
  337. handleBreakpoint
  338.     | displayPoint haltContext haltMethod restartMethod newContext aDebugger | 
  339.     
  340.     haltContext := thisContext sender.
  341.     haltMethod := (haltContext receiver dispatchingClass whichClassIncludesSelector: haltContext selector) compiledMethodAt: haltContext selector.
  342.     restartMethod := haltMethod client.
  343.     restartMethod frameSize > haltContext size
  344.         ifTrue: [
  345.             newContext := haltContext resizedWith: restartMethod.
  346.             newContext restart.
  347.             haltContext terminate]
  348.         ifFalse: [
  349.             newContext := haltContext restartWith: restartMethod].
  350.  
  351.     "Make sure that controllers without views are removed"
  352.     ScheduledControllers removeInvalidControllers.
  353.     displayPoint := 
  354.         (ScheduledControllers activeControllerProcess ~~ Processor activeProcess
  355.             or: [ScheduledControllers activeController == nil])
  356.             ifTrue: [Screen default bounds center]
  357.             ifFalse: [| view |
  358.                     view := ScheduledControllers activeController view.
  359.                     view displayBox center].
  360.     aDebugger := Debugger breakpointedContext: newContext proceedable: true.
  361.     self openDebugger: aDebugger
  362.         contents: (self shortStackFor: newContext)
  363.         label: 'Break Point in ', haltMethod mclass printString, '>>', haltContext selector
  364.         displayAt: displayPoint.
  365.     Processor activeProcess suspend! !
  366.  
  367. Browser flushMenus!
  368.  
  369. Inspector flushMenus!
  370.  
  371. !SmalltalkCompiler methodsFor: 'public access'!
  372.  
  373. evaluate: textOrStream in: aContext receiver: receiver notifying: aRequestor ifFail: failBlock 
  374.     "Compiles the sourceStream into a parse tree, then generates code 
  375.     into a method.  If receiver is not nil, then the text can refer to
  376.     instance variables of that receiver (the Inspector uses this).  If 
  377.     aContext is not nil, the text can refer to temporaries in that context
  378.     (the Debugger uses this).  If aRequestor is not nil, then it will
  379.     receive a notify:at: message before the attempt to evaluate is aborted. 
  380.     
  381.     Finally, the compiled method is invoked and the value returned"
  382.  
  383.     | methodNode method |
  384.     class := (aContext == nil
  385.                 ifTrue: [receiver]
  386.                 ifFalse: [aContext homeReceiver]) dispatchingClass.
  387.     self from: textOrStream
  388.         class: class
  389.         context: aContext
  390.         notifying: aRequestor.
  391.     methodNode := self translate: sourceStream noPattern: true ifFail: [^failBlock value].
  392.     method := methodNode generate.
  393.     ^context == nil
  394.         ifTrue:    [receiver performMethod: method]
  395.         ifFalse: [receiver performMethod: method with: context]! !
  396.  
  397. !Context methodsFor: 'printing'!
  398.  
  399. printOn: aStream
  400.     method printNameOn: aStream inClass: self homeReceiver dispatchingClass! !
  401.  
  402. !Context methodsFor: 'simulation-primitives'!
  403.  
  404. primPerform: rcvr selector: selector numArgs: numArgs
  405.     self findMethod: selector
  406.         class: rcvr dispatchingClass
  407.         ifFound:
  408.             [:meth :mclass |
  409.             numArgs = meth numArgs ifFalse:
  410.                 [self error: 'Wrong numArgs for perform'.
  411.                 "To continue, just return the receiver of the message."
  412.                 stackp := stackp - numArgs - 1.
  413.                 ^self].
  414.             "Squeeze the selector out of the stack"
  415.             numArgs negated to: -1 do: [:i | self localAt: stackp + i put: (self localAt: stackp + i + 1)].
  416.             stackp := stackp - 1.
  417.             ^self runMethod: meth numArgs: numArgs contextClass: MethodContext].
  418.     self error: 'Message not found: ', selector printString.
  419.     "To continue, just return the receiver of the message."
  420.     stackp := stackp - numArgs - 1! !
  421.  
  422. !Context methodsFor: 'simulation-control'!
  423.  
  424. send: selector numArgs: na
  425.     | rcvr |
  426.     rcvr := self localAt: stackp - na.
  427.     ^self
  428.         send: selector
  429.         receiver: rcvr
  430.         class: rcvr dispatchingClass
  431.         super: false
  432.         numArgs: na! !
  433.  
  434. !MethodContext methodsFor: 'accessing'!
  435.  
  436. selector
  437.     "Answer the selector of the method that created the receiver."
  438.  
  439.     ^receiver dispatchingClass 
  440.         selectorAtMethod: method 
  441.         setClass: [:ignored]!
  442.  
  443. sourceCode 
  444.     "Answer the source form of the receiver's method."
  445.     | mclass selector |
  446.     ^method getSourceForUserIfNone:
  447.         [selector := self receiver dispatchingClass selectorAtMethod: method setClass: [:mc | mclass := mc].
  448.         mclass sourceCodeForMethod: method at: selector]! !
  449.  
  450. !BlockContext methodsFor: 'accessing'!
  451.  
  452. selector
  453.     "Answer the selector of the method that created the receiver."
  454.  
  455.     | home classOfMethod |
  456.     home := self home.
  457.     home notNil
  458.         ifTrue:
  459.             [^home receiver dispatchingClass 
  460.                 selectorAtMethod: home method 
  461.                 setClass: [:ignored]].
  462.     classOfMethod := self mclass.
  463.     ^classOfMethod parserClass new parseSelector: self sourceCode! !
  464.  
  465. !Debugger methodsFor: 'context list'!
  466.  
  467. context: aContext 
  468.     "Set aContext to be the currently viewed context.  
  469.     This involves resetting all the inspectors, the viewed 
  470.     source code, and the exception handling signals."
  471.  
  472.     | oldContext class receiver |
  473.     oldContext := context.
  474.     context := aContext.
  475.     self changed: #theContext.
  476.     context == nil
  477.         ifTrue:
  478.             [contextInspector inspect: nil.
  479.             receiverInspector inspect: nil.
  480.             self changed: #text.
  481.             ^self].
  482.     receiver := self contextReceiver.
  483.     class := (receiver == nil 
  484.         ifTrue: [context mclass] ifFalse: [receiver dispatchingClass]).
  485.     Metaclass obsoleteSignal 
  486.         handle: [:ex | className := context mclass] 
  487.         do: 
  488.         [meta := class isMeta.
  489.         meta
  490.             ifTrue: [className := class soleInstance name]
  491.             ifFalse: [className := class name].
  492.         selector := context selector.
  493.         (oldContext == nil or: [oldContext method ~~ context method])
  494.             ifTrue:
  495.                 [sourceCode := context sourceCode.
  496.                 sourceMap := context sourceMap. "will compute tempNames"
  497.                 self changed: #text]].
  498.     receiver == nil
  499.         ifTrue: [receiverInspector inspect: nil.
  500.                 receiverInspector changed: #empty]
  501.         ifFalse: [receiverInspector inspect: receiver].
  502.     contextInspector inspect: context.
  503.     CompiledCode nPCMapErrorSignal
  504.         handle: [:ex | DialogView warn: ex errorString]
  505.         do: [self changed: #pc]! !
  506.  
  507. !Debugger methodsFor: 'private-menu messages'!
  508.  
  509. correct: aNotifierController
  510.     "Attempt to correct the spelling of the not-understood message and resend."
  511.     | oldSelector oldFirst oldArgs selectors guess score bestScore |
  512.     processHandle topContext selector == #doesNotUnderstand:
  513.         ifFalse: [^ aNotifierController view flash].
  514.     oldSelector := (processHandle topContext tempAt: 1) selector.
  515.     oldFirst := oldSelector first.
  516.     oldArgs := oldSelector numArgs.
  517.     selectors := processHandle topContext receiver dispatchingClass allSelectors select:
  518.             [:sel | sel first = oldFirst and: [sel numArgs = oldArgs]].
  519.     bestScore := 0.
  520.     selectors do:
  521.         [:sel |
  522.         (score := sel spellAgainst: oldSelector) > bestScore ifTrue:
  523.             [bestScore := score. guess := sel]].
  524.     (DialogView confirm: 'retry with selector:
  525.     ', guess) ifFalse: [^ aNotifierController view flash].
  526.     processHandle topContext tempAt: 1 put:
  527.         (Message selector: guess arguments: (processHandle topContext tempAt: 1) arguments).
  528.     ^ self proceed! !
  529.  
  530. !Debugger class methodsFor: 'instance creation'!
  531.  
  532. breakpointedContext: aContext proceedable: aBoolean 
  533.     | aDebugger |
  534.     aDebugger := self new.
  535.     aDebugger
  536.         process: Processor activeProcess
  537.         context: aContext
  538.         interrupted: true
  539.         proceedable: aBoolean.
  540.     ^aDebugger! !
  541.  
  542. Compiler subclass: #BreakpointCompiler
  543.     instanceVariableNames: ''
  544.     classVariableNames: ''
  545.     poolDictionaries: ''
  546.     category: 'Object Debugging'!
  547.  
  548.  
  549. !BreakpointCompiler methodsFor: 'private'!
  550.  
  551. newCodeStream
  552.     "Return an appropriate code stream"
  553.     ^CodeStream new methodClass: BreakpointMethod! !
  554.  
  555. Behavior subclass: #LightweightClass
  556.     instanceVariableNames: 'name '
  557.     classVariableNames: 'ClassMethod '
  558.     poolDictionaries: ''
  559.     category: 'Object Debugging'!
  560.  
  561.  
  562. !LightweightClass methodsFor: 'instance creation'!
  563.  
  564. initializeWithSuper: aClass
  565.     | md |
  566.     self superclass: aClass.
  567.     md := MethodDictionary new.
  568.     md at: #class
  569.             put: (ClassMethod copy mclass: self).
  570.     self methodDictionary: md.
  571.     format := (aClass instSize bitAnd: 255) bitOr: -4096.
  572.     self name: '{', aClass name, '}'.! !
  573.  
  574. !LightweightClass methodsFor: 'naming'!
  575.  
  576. name
  577.     ^name!
  578.  
  579. name: aSymbol
  580.     name := aSymbol! !
  581.  
  582. !LightweightClass methodsFor: 'printing'!
  583.  
  584. printOn: aStream  
  585.     "Append to the argument aStream a sequence of characters that identifies the receiver."
  586.  
  587.     aStream nextPutAll: self name! !
  588.  
  589. !LightweightClass methodsFor: 'testing'!
  590.  
  591. isMeta
  592.     ^false! !
  593.  
  594. !LightweightClass methodsFor: 'compiling'!
  595.  
  596. compile: code notifying: requestor ifFail: failBlock 
  597.     "Compile the argument, code, as source code in the context of the receiver and
  598.     install the result in the receiver's method dictionary.  The argument requestor is to  
  599.     be notified if an error occurs. The argument code is either a string or an 
  600.     object that converts to a string or a PositionableStream on an object that   
  601.     converts to a string.  This method does not save the source code. 
  602.     Evaluate the failBlock if the compilation does not succeed."
  603.  
  604.     | methodNode selector save method oldMethod |
  605.     save := code asString copy.
  606.     methodNode := self compilerClass new
  607.                 compile: code
  608.                 in: self
  609.                 notifying: requestor
  610.                 ifFail: failBlock.
  611.     selector := methodNode selector.
  612.     method := methodNode generate.
  613.     method sourceCode: save.
  614.     oldMethod := self compiledMethodAt: selector ifAbsent: [nil].
  615.     (oldMethod notNil and: [oldMethod isBreakpoint])
  616.         ifTrue: [oldMethod client: method]
  617.         ifFalse: [
  618.             self addSelector: selector withMethod: method].
  619.     ^selector!
  620.  
  621. compilerClass
  622.     ^LightweightCompiler! !
  623. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  624.  
  625. LightweightClass class
  626.     instanceVariableNames: ''!
  627.  
  628.  
  629. !LightweightClass class methodsFor: 'class initialization'!
  630.  
  631. initialize
  632.     "LightweightClass initialize"
  633.     ClassMethod := (LightweightCompiler new
  634.         compile: 'class ^self dispatchingClass superclass'
  635.         in: Object
  636.         notifying: nil
  637.         ifFail: []) generate.
  638.     ClassMethod sourceCode: 'class
  639.     ^self dispatchingClass superclass'! !
  640.  
  641. !LightweightClass class methodsFor: 'instance creation'!
  642.  
  643. newWithSuper: aClass
  644.     ^self basicNew initializeWithSuper: aClass! !
  645.  
  646. CompiledMethod variableSubclass: #CompiledMethodWithSource
  647.     instanceVariableNames: ''
  648.     classVariableNames: ''
  649.     poolDictionaries: ''
  650.     category: 'Object Debugging'!
  651.  
  652.  
  653. !CompiledMethodWithSource methodsFor: 'source code management'!
  654.  
  655. getSource
  656.     ^sourceCode!
  657.  
  658. methodWithSource
  659.  
  660.     sourceCode notNil ifTrue: [^self].
  661.     ^nil!
  662.  
  663. sourceCode: aString
  664.     sourceCode := aString! !
  665.  
  666. Compiler subclass: #LightweightCompiler
  667.     instanceVariableNames: ''
  668.     classVariableNames: ''
  669.     poolDictionaries: ''
  670.     category: 'Object Debugging'!
  671.  
  672.  
  673. !LightweightCompiler methodsFor: 'private'!
  674.  
  675. newCodeStream
  676.     "Return an appropriate code stream"
  677.     ^CodeStream new methodClass: CompiledMethodWithSource! !
  678.  
  679. CompiledMethod variableSubclass: #BreakpointMethod
  680.     instanceVariableNames: 'clientMethod '
  681.     classVariableNames: ''
  682.     poolDictionaries: ''
  683.     category: 'Object Debugging'!
  684.  
  685.  
  686. !BreakpointMethod methodsFor: 'initialization'!
  687.  
  688. bytes: aByteString mclass: aClass sourceCode: aSourcePointer
  689.     bytes := aByteString.
  690.     mclass := aClass.
  691.     sourceCode := aSourcePointer!
  692.  
  693. client: aCompiledMethod
  694.     clientMethod := aCompiledMethod.
  695.     aCompiledMethod agent: self! !
  696.  
  697. !BreakpointMethod methodsFor: 'accessing'!
  698.  
  699. client
  700.     ^clientMethod! !
  701.  
  702. !BreakpointMethod methodsFor: 'source code management'!
  703.  
  704. getSource
  705.     "Answer the source code for the receiver.  Answer nil if this method
  706.     has no stored source."
  707.  
  708.     ^clientMethod getSource! !
  709.  
  710. !BreakpointMethod methodsFor: 'testing'!
  711.  
  712. isBreakpoint
  713.     ^true! !
  714. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  715.  
  716. BreakpointMethod class
  717.     instanceVariableNames: ''!
  718.  
  719.  
  720. !BreakpointMethod class methodsFor: 'instance creation'!
  721.  
  722. on: aCompiledMethod selector: sel inClass: class
  723.     | b |
  724.  
  725.     b := (class breakpointCompilerClass new
  726.             compile: (self codeStringFor: sel)
  727.             in: class
  728.             notifying: nil
  729.             ifFail: []) generate. 
  730.     ^b client: aCompiledMethod! !
  731.  
  732. !BreakpointMethod class methodsFor: 'private'!
  733.  
  734. codeStringFor: sel
  735.     | k prefix count |
  736.     sel isInfix
  737.         ifTrue: [prefix := sel, ' arg1 ']
  738.         ifFalse: [ 
  739.             sel isKeyword
  740.                 ifFalse: [prefix := sel, ' ']
  741.                 ifTrue: [k := sel keywords.
  742.                     prefix := ''.
  743.                     count := 1.
  744.                     k do: [ :x | prefix := prefix, ' ', x, ' arg', count printString, ' '.
  745.                             count := count + 1]]].
  746.                 
  747.     ^prefix, 'NotifierView handleBreakpoint'! !
  748.  
  749. Browser subclass: #LightweightClassBrowser
  750.     instanceVariableNames: 'lightweightClass listUpToClass '
  751.     classVariableNames: 'LightweightSelectorMenu '
  752.     poolDictionaries: ''
  753.     category: 'Object Debugging'!
  754.  
  755.  
  756. !LightweightClassBrowser methodsFor: 'initialize-release'!
  757.  
  758. onObject: anObject
  759.     "Set the receiver to be a browser on anObject's lightweight class (this method assumes
  760.     the object has a lightweight class, which is guaranteed in the class method newOnObject:), 
  761.     so that therefore the organization is the system organizer."
  762.  
  763.     lightweightClass := anObject dispatchingClass.
  764.     listUpToClass := lightweightClass.
  765.     className := lightweightClass name.
  766.     textMode := #methodDefinition! !
  767.  
  768. !LightweightClassBrowser methodsFor: 'class list'!
  769.  
  770. className: selection
  771.     "Set the receiver's currently selected class to be selection and 
  772.     update the message category list.  If this class no longer exists,
  773.     print a message to that effect in the system transcript, if it is open."
  774.  
  775.     self halt!
  776.  
  777. selectedClass
  778.     "Answer the class object that is currently selected."
  779.  
  780.     ^lightweightClass! !
  781.  
  782. !LightweightClassBrowser methodsFor: 'doIt/accept/explain'!
  783.  
  784. acceptText: aText from: aController
  785.     "Text has been changed.  Store or compile the text, depending on 
  786.     the current mode of the receiver."
  787.  
  788.     textMode == #methodDefinition ifTrue:
  789.         [^ self acceptMethod: aText from: aController].
  790.     self halt.
  791.     ^ false! !
  792.  
  793. !LightweightClassBrowser methodsFor: 'selector list'!
  794.  
  795. newSelectorList: initialSelection
  796.     "Set the currently selected message selector to be initialSelection."
  797.     selector := initialSelection.
  798.     self changed: #selector!
  799.  
  800. selector: selection 
  801.     "Set the receiver's currently selected message selector to be 
  802.     selection. If the selection has been separately removed from the 
  803.     system, then print a message to that effect in the system 
  804.     transcript, if it is open."
  805.  
  806.     selector := selection.
  807.     Dictionary keyNotFoundSignal
  808.         handle: 
  809.             [:ex | 
  810.             DialogView warn: 'selector ' , selector , ' no longer exists.'.
  811.             ex return]
  812.         do: ["KeyNotFoundSignal is raised when the selector name 
  813.             selected 
  814.             in a browser is already removed in another browser."
  815.             self textMode: #methodDefinition]!
  816.  
  817. selectorList
  818.     "Answer the sequenceable collection containing the message selectors that 
  819.     the receiver accesses via the currently selected class and message category."
  820.  
  821.     | selSet  selClass | 
  822.     selClass := self selectedClass.
  823.     selSet := selClass selectors asSet.
  824.  
  825.     [selClass = listUpToClass]
  826.         whileFalse: [ selClass := selClass superclass.
  827.             selSet addAll: selClass selectors].
  828.     ^selSet asSortedCollection!
  829.  
  830. selectorMenu
  831.     "Answer a Menu of operations on message selectors to be 
  832.     displayed when the operate menu button is pressed."
  833.  
  834.     "ObjectBrowser flushMenus" 
  835.     selector == nil ifTrue: [^ nil].
  836.     LightweightSelectorMenu == nil ifTrue:
  837.         [LightweightSelectorMenu := PopUpMenu
  838.             labels: 'hardcopy\senders\implementors\messages...\breakpoint\remove...' withCRs
  839.             lines: #(1 4 5)
  840.             values: #(printOutMessage browseSenders browseImplementors browseMessages breakpointMethod removeMethod)].
  841.     ^ LightweightSelectorMenu! !
  842.  
  843. !LightweightClassBrowser methodsFor: 'private-selector functions'!
  844.  
  845. acceptMethod: aText from: aController
  846.     | newSelector |
  847.  
  848.     newSelector := self selectedClass
  849.                 compile: aText
  850.                 notifying: aController.
  851.     newSelector == nil ifTrue: [^false].
  852.     self newSelectorList: newSelector.
  853.     ^true! !
  854.  
  855. !LightweightClassBrowser methodsFor: 'category list'!
  856.  
  857. category
  858.     ^'**Lightweight Class**'!
  859.  
  860. category: aSelection
  861.     ^self!
  862.  
  863. categoryList
  864.     ^Array with: self category!
  865.  
  866. categoryMenu
  867.     ^PopUpMenu labels: 'update' values: #(updateSelectors)! !
  868.  
  869. !LightweightClassBrowser methodsFor: 'private-category functions'!
  870.  
  871. updateSelectors
  872.  
  873.     self newSelectorList: selector! !
  874.  
  875. !LightweightClassBrowser methodsFor: 'superclass list'!
  876.  
  877. superclass
  878.     ^listUpToClass!
  879.  
  880. superclass: aSelection
  881.     "listUpToClass := aSelection.
  882.     self newSelectorList: selector"
  883.  
  884.     ^self!
  885.  
  886. superclassList
  887.     ^Array with: listUpToClass!
  888.  
  889. superclassMenu
  890.     | c choice |
  891.     c := self selectedClass withAllSuperclasses.
  892.  
  893.     choice := (PopUpMenu labelArray: (c collect: [ :x | x name])) startUp.
  894.     choice = 0
  895.         ifTrue: [^nil].
  896.     listUpToClass := c at: choice.
  897.     self changed: #superclass.
  898.     self changed: #selector.
  899.     ^nil! !
  900.  
  901. !LightweightClassBrowser methodsFor: 'text'!
  902.  
  903. text
  904.     | c |
  905.     selector == nil
  906.         ifTrue: [^ self class sourceCodeTemplate asText]
  907.         ifFalse: [ 
  908.             c := self selectedClass whichClassIncludesSelector: selector.
  909.             ^ c sourceMethodAt: selector]! !
  910. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  911.  
  912. LightweightClassBrowser class
  913.     instanceVariableNames: ''!
  914.  
  915.  
  916. !LightweightClassBrowser class methodsFor: 'class initialization'!
  917.  
  918. flushMenus 
  919.     "Cause all menus to be newly created (so changes appear)." 
  920.     "ObjectBrowser flushMenus."
  921.  
  922.     super flushMenus.
  923.     LightweightSelectorMenu := nil! !
  924.  
  925. !LightweightClassBrowser class methodsFor: 'instance creation'!
  926.  
  927. newOnObject: anObject
  928.     "Create and schedule a view that is a browser for anObject."
  929.  
  930.     self openObjectBrowserOn: anObject becomeLightweight! !
  931.  
  932. !LightweightClassBrowser class methodsFor: 'view creation'!
  933.  
  934. openObjectBrowserOn: anObject
  935.     "Create and schedule a browser on the lightweight class of anObject."
  936.  
  937.     self openObjectBrowserOn: anObject withTextState: nil!
  938.  
  939. openObjectBrowserOn: anObject withTextState: anArray
  940.     "Create and schedule a browser on the lightweight class currently selected by aBrowser.
  941.      anArray holds the initial text state."
  942.  
  943.     | aBrowser lineHeightBlock topView topWindow   |
  944.  
  945.     lineHeightBlock := self lineHeightBlock.
  946.     aBrowser := self new onObject: anObject.
  947.     topWindow := ScheduledWindow model: aBrowser 
  948.                         label: 'Lightweight Class Browser' 
  949.                         minimumSize: 400@250.
  950.     topView := DependentComposite new.
  951.     self
  952.         addCategoryViewTo: topView
  953.             in: (LayoutFrame new
  954.             leftOffset: 0;
  955.             topOffset: 0;
  956.             rightFraction: 0.5;
  957.             bottomOffset: lineHeightBlock) on: aBrowser readOnly: true;
  958.         addSuperclassListViewTo: topView
  959.             in: (LayoutFrame new
  960.             leftFraction: 0.5;
  961.             topOffset: 0;
  962.             rightFraction: 1.0;
  963.             bottomOffset: lineHeightBlock) on: aBrowser readOnly: true;
  964.         addFormattedSelectorViewTo: topView
  965.             in: (LayoutFrame new 
  966.                 leftOffset: 0;
  967.                 topOffset: lineHeightBlock;
  968.                 rightFraction: 1.0;
  969.                 bottomFraction: 0.4) on: aBrowser readOnly: false;
  970.         addTextViewTo: topView in: (0@0.4 corner: 1.0@0.75) on: aBrowser initialSelection: nil initialState: anArray.
  971.     Inspector view: (Inspector inspect: anObject) in: (0@0.75 corner: 1.0@1.0) of: topView.
  972.     topWindow component: topView.
  973.     topWindow icon: (Icon constantNamed: #classBrowser).
  974.     topWindow openWithExtent: ((topWindow  minimumSize * 3 + topWindow maximumSize) // 4)! !
  975.  
  976. !LightweightClassBrowser class methodsFor: 'private-view creation'!
  977.  
  978. addSuperclassListViewTo: aContainer in: area on: aBrowser readOnly: readOnly
  979.  
  980.     | edgeDecorator |
  981.     edgeDecorator := LookPreferences edgeDecorator on:
  982.         (SelectionInListView on: aBrowser printItems: true oneItem: readOnly
  983.             aspect: #superclass change: #superclass: list: #superclassList
  984.             menu: #superclassMenu initialSelection: #superclass).
  985.     readOnly ifTrue: [edgeDecorator noVerticalScrollBar].
  986.     ^aContainer add: edgeDecorator in: area! !
  987.  
  988. SelectionInListView subclass: #FormattedListView
  989.     instanceVariableNames: 'printMsg printReceiver sendParameter '
  990.     classVariableNames: ''
  991.     poolDictionaries: ''
  992.     category: 'Object Debugging'!
  993.  
  994.  
  995. !FormattedListView methodsFor: 'initialization'!
  996.  
  997. initialize
  998.     super initialize.
  999.     printReceiver := nil.
  1000.     printMsg := #printString.
  1001.     sendParameter := false!
  1002.  
  1003. printBlock: aBlock
  1004.     self receiver: aBlock message: #value: useParameter: true!
  1005.  
  1006. printMessage: aSelector
  1007.     self receiver: nil message: aSelector useParameter: false!
  1008.  
  1009. printReceiver: anObject printMessage: aSelector
  1010.     self receiver: anObject message: aSelector useParameter: true!
  1011.  
  1012. receiver: aReceiver message: aSelector useParameter: aBoolean
  1013.     printReceiver := aReceiver.
  1014.     printMsg := aSelector.
  1015.     sendParameter := aBoolean.
  1016.     self list: self getList! !
  1017.  
  1018. !FormattedListView methodsFor: 'list access'!
  1019.  
  1020. displayableLinesFrom: anArray
  1021.     "Answer a collection of displayable lines from anArray." 
  1022.     
  1023.     ^sendParameter
  1024.         ifTrue: [anArray collect: [ :elt | printReceiver perform: printMsg with: elt]]
  1025.         ifFalse: [anArray collect: [ :elt | elt perform: printMsg]]! !
  1026. LightweightClass initialize!
  1027.  
  1028.